#lang racket


(require "../base/main.rkt")
(require "../constructors/main.rkt")
(require "../parametrization/main.rkt")

(require (prefix-in im: "ac-imediate.rkt"))

(provide (rename-out (im:load-autocad-imediate load-autocad-defer))
         ac-evaluate
         ac-evaluate-toplevel)


(define (eval-arc-node node)
  (im:arc (arc-node-angle node) (arc-node-radius node)))

(define (eval-elliptical-arc-node node)
  (im:elliptical-arc
   (elliptical-arc-node-angle node)
   (elliptical-arc-node-x-radius node)
   (elliptical-arc-node-y-radius node)))

(define (eval-circle-node node)
  (im:circle (circle-node-radius node)))

(define (eval-donut-node node)
  (im:donut
   (donut-node-inner-radius node)
   (donut-node-outer-radius node)))

(define (eval-ellipse-node node)
  (im:ellipse
   (ellipse-node-x-radius node)
   (ellipse-node-y-radius node)))

(define (eval-helix-2d-node node)
  (im:helix-2d
   (helix-2d-node-base-radius node)
   (helix-2d-node-top-radius node)
   (helix-2d-node-turns node)
   (helix-2d-node-turn-height node)
   (helix-2d-node-direction node)))

(define (eval-line-node node)
  (im:line
   (line-node-points node)))

(define (eval-ngon-node node)
  (im:ngon
   (ngon-node-width node)
   (ngon-node-sides node)))

(define (eval-nurbs-curve-node node)
  (im:nurbs-curve
   (nurbs-curve-node-controls node)
   (nurbs-curve-node-knots node)))

(define (eval-nurbs-surface-node node)
  (im:nurbs-surface
   (nurbs-surface-node-controls node)
   (nurbs-surface-node-u-knots node)
   (nurbs-surface-node-v-knots node)))

(define (eval-rectangle-node node)
  (im:rectangle
   (rectangle-node-width node)
   (rectangle-node-length node)))

(define (eval-spline-node node)
  (im:spline (spline-node-points node)))

(define (eval-star-node node)
  (im:star
   (star-node-width node)
   (star-node-sides node)
   (star-node-stride node)))


(define (eval-box-node node)
  (im:box
   (box-node-width node)
   (box-node-length node)
   (box-node-height node)))

(define (eval-cone-node node)
  (im:cone
   (cone-node-radius node)
   (cone-node-height node)))

(define (eval-cone-frustrum node)
  (im:cone-frustrum
   (cone-frustrum-node-base-radius node)
   (cone-frustrum-node-top-radius node)
   (cone-frustrum-node-height node)))

(define (eval-cylinder-node node)
  (im:cylinder
   (cylinder-node-radius node)
   (cylinder-node-height node)))

(define (eval-pipe-node node)
  (im:pipe
   (pipe-node-inner-radius node)
   (pipe-node-outer-radius node)
   (pipe-node-height node)))

(define (eval-sphere-node node)
  (im:sphere (sphere-node-radius node)))


; operations

; edit: review and test
(define (eval-extrude-node node)
  (im:extrude
   (extrude-node-length node)
   (evaluate (extrude-node-surface node))))

(define (eval-intersect-node node)
  (im:intersect
   (evaluate (intersect-node-shape1 node))
   (evaluate (intersect-node-shape2 node))))

(define (eval-join node)
  (im:join
   (map evaluate (join-node-shapes node))))

(define (eval-loft node)
  (im:loft
   (loft-node-closed node)
   (map evaluate (loft-node-shapes node))))

(define (eval-move-node node)
  (im:move
   (move-node-position node)
   (evaluate (move-node-shape node))))

(define (eval-offset-node node)
  (im:offset
   (offset-node-distance node)
   (evaluate (offset-node-shape node))))

(define (eval-rotate-node node)
  (im:rotate
   (rotate-node-angle node)
   (rotate-node-normal node)
   (evaluate (rotate-node-shape node))))

(define (eval-scale-node node)
  (im:scale
   (scale-node-scale node)
   (evaluate (scale-node-shape node))))

(define (eval-subtract-node node)
  (im:subtract
   (evaluate (subtract-node-shape1 node))
   (evaluate (subtract-node-shape2 node))))

(define (eval-sweep node)
  (im:sweep
   (evaluate (sweep-node-shape node))
   (evaluate (sweep-node-path node))))

(define (eval-union-node node)
  (im:union
   (evaluate (union-node-shape1 node))
   (evaluate (union-node-shape2 node))))


; lang

(define (eval-on-top node)
  (im:on-top
   (evaluate (on-top-node-shape1 node))
   (evaluate (on-top-node-shape2 node))))


; eval-parametrize

(define (arc-length begin-radians end-radians (counter-clockwise? #t))
  (cond ((< begin-radians end-radians) (- end-radians begin-radians))
        (counter-clockwise? (- (+ end-radians 2pi) begin-radians))
        (else (arc-length end-radians begin-radians))))

(define (eval-parametrize-arc shape)
  (let ((center (im:get-arc-center shape))
        (begin-angle (im:get-arc-begin-angle shape))
        (end-angle (im:get-arc-end-angle shape))
        (radius (im:get-arc-radius shape)))
    (let* ((angle (arc-length begin-angle end-angle))
           (translation (apply m.translate center))
           (rotation (m.rotate begin-angle 0 0 1)))
      (make-transformation-parametric
       (make-transformation-parametric
        (make-arc-curve angle radius)
        rotation)
       translation))))

(define (eval-parametrize node)
  (im:begin-undo-mark)
  (let ((shape (evaluate (parametrize-node-shape node))))
    (im:end-undo-mark)
    (finally
     (if (im:arc? shape)
         (eval-parametrize-arc shape)
         (error 'eval-parametrize "Unhandled parametrize type"))
     (λ () (im:undo)))))

; /eval-parametrize

; autocad

(define (eval-arc-ppp node)
  (im:arc-ppp
   (arc-ppp-node-p1 node)
   (arc-ppp-node-p2 node)
   (arc-ppp-node-p3 node)))

; /autocad

; eval

(define (ac-evaluate-node node)
  (cond
    ;; primitives
    ((arc-node? node) (eval-arc-node node))
    ((elliptical-arc-node? node) (eval-elliptical-arc-node node))
    ((circle-node? node) (eval-circle-node node))
    ((donut-node? node) (eval-donut-node node))
    ((ellipse-node? node) (eval-ellipse-node node))
    ((helix-2d-node? node) (eval-helix-2d-node node))
    ((line-node? node) (eval-line-node node))
    ((ngon-node? node) (eval-ngon-node node))
    ((nurbs-curve-node? node) (eval-nurbs-curve-node node))
    ((nurbs-surface-node? node) (eval-nurbs-surface-node node))
    ((rectangle-node? node) (eval-rectangle-node node))
    ((spline-node? node) (eval-spline-node node))
    ((star-node? node) (eval-star-node node))
    ;((text-node? node) (eval-text-node node))
    
    ((box-node? node) (eval-box-node node))
    ((cone-node? node) (eval-cone-node node))
    ((cone-frustrum-node? node) (eval-cone-frustrum node))
    ((cylinder-node? node) (eval-cylinder-node node))
    ((pipe-node? node) (eval-pipe-node node))
    ((sphere-node? node) (eval-sphere-node node))
    
    ;; operations
    ((extrude-node? node) (eval-extrude-node node))
    ((intersect-node? node) (eval-intersect-node node))
    ((join-node? node) (eval-join node))
    ((loft-node? node) (eval-loft node))
    ((move-node? node) (eval-move-node node))
    ((offset-node? node) (eval-offset-node node))
    ((rotate-node? node) (eval-rotate-node node))
    ((scale-node? node) (eval-scale-node node))
    ((subtract-node? node) (eval-subtract-node node))
    ((sweep-node? node) (eval-sweep node))
    ((union-node? node) (eval-union-node node))
    
    ;; language
    ((on-top-node? node) (eval-on-top node))
    ((parametrize-node? node) (eval-parametrize node))
    
    ((arc-ppp-node? node) (eval-arc-ppp node))
    
    (else
     (error
      'ac-evaluate-toplevel
      (format "Unhandled node ~A" node)))))

(define (ac-evaluate node)
  (cond
    ((pair? node)
     (cons
      (ac-evaluate (car node))
      (ac-evaluate (cdr node))))
    ((node? node)
     (ac-evaluate-node node))
    (else
     node)))

(define (ac-evaluate-toplevel form)
  (begin0
    (ac-evaluate form)
    (im:redraw)))